(in-package :com.lispniks.faq)

(defparameter *faqs* '("faq" "staging-faq" #+(or)"comp.lang.lisp-faq" "lispfaq"))

(defun render-faqs ()
  (loop for faq in *faqs*
     for input = (make-pathname :name faq :type "txt")
     for output = (make-pathname :name faq :type "html")
     when (not (file-exists-p input))
     do (warn "Input file ~a not found." input)
     else when (file-newer-p input output) 
     do (format t "Rendering ~a into ~a.~%" input output)
       (render-faq input)
     else do
       (format t "~a up to date.~%" output)))

(defun file-newer-p (a b)
  (flet ((safe-write-date (file)
	   (or (file-write-date file) 0)))
    (> (safe-write-date a) (safe-write-date b))))

(defun render-faq (input &optional output)
  "Generate HTML version of FAQ."
  (let ((*paragraph-tags* '("modeline"))
	(*parse-links* nil))
    (with-tag-translations ((:cl . (:span :class :cl))
			    (:datestamp . datestamp)
			    (:figure . figure))
      (let ((com.gigamonkeys.markup::*preprocessors* '(preprocess-faq)))
	(if output
	    (render :html input output)
	    (render :html input))))))

(defun datestamp (tag body)
  (declare (ignore tag body))
  (format-iso-8601-time (get-universal-time)))

(defun figure (tag body)
  (declare (ignore tag))
  `(:img :src ,@body))

(defun parse-faq (input)
  (let ((com.gigamonkeys.markup::*subdocument-tags* (list* :faq :question :answer com.gigamonkeys.markup::*subdocument-tags*)))
    (parse-file input)))

(defun preprocess-faq (sexp)
  (let ((sections (group-questions-by-section (remove-if-not #'(lambda (x) (member (car x) '(:h2 :h3))) sexp))))
    (destructuring-bind (h1 datestamp &rest faqs) (strip-invisible sexp)
      `(,h1
	,datestamp
	((:div :class :top-questions)
	 ,@(loop for s from 1 
	      for thing in sections
	      nconc
	      (destructuring-bind (section &rest questions) thing
		`(,section
		  ,@(loop for q from 1 
		       for question in questions collect 
			 `(:li ((:a :href ,(format nil "#s~dq~d" s q)) ,@(rest question))))))))
	,@(loop with s = 0
	     with q = 0
	     for thing in faqs
	     when (eql (car thing) :h2) do (incf s) (setf q 0)
	     when (eql (car thing) :h3) do (incf q) and
	     collect `(:a :name ,(format nil "s~dq~d" s q))
	     collect thing)))))

(defun group-questions-by-section (sections-and-questions)
  (flet ((section-p (thing) (eql (car thing) :h2)))
    (when sections-and-questions
      (assert (section-p (first sections-and-questions)))
      (let* ((section (first sections-and-questions))
	     (next-section-start (member-if #'section-p (rest sections-and-questions)))
	     (questions (ldiff (rest sections-and-questions) next-section-start)))
	(list* (list* section questions) (group-questions-by-section next-section-start))))))

(defun markupify (file)
  (with-open-file (in file)
    (with-open-file (out "faq.txt" :direction :output :if-exists :supersede)
      (loop for expr = (read in nil in)
	 until (eql expr in)
	 do (destructuring-bind (&key q a) expr
	      (format out "\\faq{~%\\question{~a}~%\\answer{~@[~a~]}~%}~2%" q a))))))

(defun faq->outline (input &optional (outline "faq-outline.txt"))
  (let ((faq (parse-faq input))
	(com.gigamonkeys.markup::*invisible* (remove :modeline com.gigamonkeys.markup::*invisible*)))
    (render-sexp :markup
		 `((:modeline "-*- mode: outline; -*-")
		   (:h1 "Common Lisp FAQ")
		   (:h2 "Section")
		   ,@(loop for thing in faq when (eql (first thing) :faq) nconc
			  (destructuring-bind (faq-tag (q-tag &rest question)
						       (a-tag &rest answer)) thing
			    (declare (ignore faq-tag q-tag a-tag))
			    (when (cdr question) (warn "Question too long: ~s" question))
			    `((:h3 ,@(cdar question)) ,@answer))))
		 outline)))


(defun lispfaq->outline (lispfaq &optional (output "lispfaq.txt"))
  (with-tag-translations ((:symbol . :code)
			  (:function . :cl))
    (render-sexp :markup lispfaq output)))